( SYSTEM CONFIGURATION - LOAD SCREEN ) ( 27 MAR 86 JBM ) ( LOAD THIS SCREEN TO CONFIGURE YOUR SYSTEM ) 40 LOAD ( EDITOR ) 10 LOAD ( CLOSE, OPEN, SAVE ) 11 LOAD ( DUMP HEX & ASCII ) ;S ( SYSTEM INSTALLATION - SAVE SYSTEM ) ( 24 JAN 86 JBM ) ( LOAD THIS SCREEN TO SAVE THE CURRENT DICTIONARY TO DISK ) BASE @ FORTH DEFINITIONS HEX LATEST 0C +ORIGIN ! ( TOP NFA ) HERE 1C +ORIGIN ! ( INITIAL FENCE VALUE ) HERE 1E +ORIGIN ! ( DICTIONARY POINTER ) VOC-LINK @ 20 +ORIGIN ! ( VOCABULARY LINK ) HERE FENCE ! ( UPDATE THE CURRENT FENCE ) SAVE F.DICT ( SAVE THE NEW DICTIONARY ) BASE ! ;S Not defined in this context Stack empty Dictionary full Assembler addressing mode undefined Redefined 5 6 Stack full ProDOS MLI error during R/W ProDOS MLI error during CLOSE ProDOS MLI error during OPEN ProDOS MLI error during SAVE ProDOS MLI error during GET.BLK 13 14 Adapted for ProDOS by John B. Matthews, M.D. String not found Permitted only in compilation Permitted only in execution Conditional not paired Definition not finished Can't be forgotten Use only when LOADing Line # outside editor range Single character expected 25 26 27 28 29 30 31 ( SYSTEM NOTES ) ( 04 FEB 86 JBM )This version of FIG-FORTH was adapted for ProDOS from the 6502 FORTH kernel by William F. Ragsdale. It is standard FIG- FORTH with several extensions to work with ProDOS: MLI (parameter.list command.code -- error.code) calls the Pro DOS Machine Language Interface (MLI). CALL (address -- ) calls the machine language routine at the address on Top Of the Stack (TOS). Registers are passed in zero page locations 0, 1, & 2 for A, X & Y respectively. BYE ( -- ) flushes & closes any open files and exits to ProDOS. FSIZE ( -- n ) a file of screens (named F.DISK) is opened when FORTH starts up. The constant FSIZE specifies the size of this file. It is used by DR1 to set OFFSET and by R/W to determine which open file to use. ( SYSTEM NOTES ) ( 04 FEB 86 JBM )CLOSE ( -- ) closes the second file opened. The first file, opened at startup, is closed only after BYE. Additional files may be opened but they will not be LISTable. OPEN pathname ( -- ) opens the specified pathname as a second file. Each call to OPEN closes the previous second file. SAVE pathname ( -- ) save the FORTH dictionary from its origin at $800 (2048) to HERE with the specified pathname. See SYSTEM INSTALLATION about setting FENCE etc. before SAVEing. MON ( -- ) enters the Apple monitor. Control-Y or control-RESET will return to FORTH via a warm start. Hard disk users should note that the second file opened may be as lage as desired (up to 16 MB). If the first file (F.DISK) is enlarged the constant FSIZE should be changed to reflect the new size. ( SYSTEM NOTES ) ( 04 FEB 86 JBM )Memory Map $0-2: A, X, & Y are filled from and restored to here for CALL $60-DE: the FORTH computation stack (grows downward). $E5-F5: interpreter registers (see assembler). $100-1FF: the FORTH return stack (grows downward). $200-280: Terminal Input Buffer (TIB). $400-7FF: primary screen page. $800-A800: FORTH dictionary space. $B200-B5FF: first ProDOS file buffer. Others grow downward. $B678-BE80: FORTH file buffers. $BE80-BEFF: FORTH user variables. Seventeen are predefined. $BF00-FFFF: ProDOS. ( CLOSE, OPEN, SAVE ) ( 28 JAN 86 JBM )BASE @ FORTH DEFINITIONS HEX HERE 1 C, 2 C, CONSTANT CLIST HERE 3 C, 0 , BF70 @ 400 - , 0 C, CONSTANT OLIST HERE 4 C, 2 C, 800 , 0 , 0 , CONSTANT RWLIST : CLOSE FLUSH EMPTY-BUFFERS CLIST CC MLI DUP 43 = 0= AND 9 ?ERROR ; : OPEN CLOSE BL WORD HERE OLIST 1+ ! OLIST C8 MLI A ?ERROR ; : SAVE OPEN HERE 800 DUP RWLIST 2+ ! - RWLIST 4 + ! RWLIST CB MLI B ?ERROR CLOSE ; BASE ! ;S ( DUMP - HEX & ASCII ) ( 04 FEB 86 JBM )BASE @ FORTH DEFINITIONS HEX 10 CONSTANT WD ( WIDTH OF DUMPED LINE ) : (DUMP) DUP 1 ! F940 CALL 3A EMIT SPACE WD 0 DO DUP I + C@ 0 C! FDDA CALL SPACE LOOP WD 0 DO DUP I + C@ 80 OR DUP A0 < IF DROP 2E THEN EMIT LOOP DROP ; ( addr -- DUMP WD BYTES WITH ASCII ) : DUMP FFF8 AND DUP 80 + SWAP DO I (DUMP) CR WD +LOOP ; ( addr -- DUMP 128 BYTES FROM ADDR ) : DWORD [COMPILE] ' NFA DUMP ; ( DUMP THE NEXT WORD INPUT ) BASE ! ;S ( HELLO - SET A STARTUP WORD ) ( 01 MAR 86 JBM )( LOAD YOUR WORDS THEN LOAD THIS SCREEN TO CREATE A HELLO WORD ) BASE @ FORTH DEFINITIONS HEX : HELLO SP! DECIMAL DR0 [COMPILE] FORTH DEFINITIONS 18 0 DO CR LOOP 1 LIST CR CR ( OR WHATEVER YOU WANT HERE ) QUIT ; ( OR BYE OR WHATEVER YOUR WORD DOES AT EXIT TIME ) ( CAUSE COLD TO GO TO HELLO ) ' HELLO 100 /MOD 180D C! 1811 C! ( THEN LOAD SYSTEM INSTALLATION TO LOCK IT DOWN AND SAVE IT ) BASE ! ;S ( BALANCE ) ( 27 MAR 86 JBM )( MANIPULATE A RUNNING BALANCE TO VERIFY A LEDGER ) BASE @ FORTH DEFINITIONS DECIMAL : 2VAR <BUILDS , , DOES> ; : 2@ DUP >R 2+ @ R> @ ; : 2! DUP >R ! R> 2+ ! ; : $.R >R SWAP OVER DABS <# # # 46 HOLD #S SIGN 36 HOLD #> R> OVER - SPACES TYPE ; 0 0 2VAR BALANCE : B. ." Balance = " BALANCE 2@ 12 $.R SPACE SPACE ; : B= ( d -- ESTABLISH INITIAL BALANCE ) BALANCE 2! B. ; : B+ ( d -- ADD TOS TO BALANCE ) BALANCE 2@ D+ BALANCE 2! B. ; : B- ( d -- DEBIT BALANCE ) DMINUS B+ ; BASE ! ;S ( CONVERT DOS TO PRODOS SCREENS 1 ) ( 15 FEB 86 JBM )BASE @ FORTH DEFINITIONS HEX HERE ( block-read parameter list ) 3 C, E0 C, 0 , 0 , CONSTANT BRP HERE ( sector-block map ) 0 C, 7 C, 6 C, 6 C, 5 C, 5 C, 4 C, 4 C, 3 C, 3 C, 2 C, 2 C, 1 C, 1 C, 0 C, 7 C, CONSTANT MAP.B HERE ( map which half of block has the sector ) 0 C, 0 C, 1 C, 0 C, 1 C, 0 C, 1 C, 0 C, 1 C, 0 C, 1 C, 0 C, 1 C, 0 C, 1 C, 1 C, CONSTANT MAP.H --> ( CONVERT DOS TO PRODOS SCREENS 2 ) ( 15 FEB 86 JBM ): SET.UNIT ( slot drive -- ) 80 * SWAP 10 * OR BRP 1+ ! ; : GET.BLK ( block -- addr ) BRP 4 + ! HERE BRP 2 + ! BRP 80 MLI C ?ERROR HERE ; : GET.SEC ( sector -- addr ) 10 /MOD SWAP >R 8 * R MAP.B + C@ + GET.BLK R> MAP.H + C@ 100 * + ; : CONVERT ( source dest -- ) BLOCK SWAP 4 * DUP 4 + SWAP DO I GET.SEC OVER 100 CMOVE 100 + LOOP DROP UPDATE ; : TRANSFER ( source dest count -- ) 0 DO OVER I + OVER I + CONVERT LOOP DROP DROP FLUSH ; BASE ! ;S ( PLIST ) ( 17 FEB 86 JBM )BASE @ DECIMAL FORTH DEFINITIONS : PLIST ( first last -- PRINT SCREEN NUMBERS FIRST THRU LAST ) 0 ROT ROT 1+ SWAP DO I DUP 3 PR# LIST 1 PR# LIST CR CR 1+ DUP 3 = IF 12 EMIT DROP 0 THEN LOOP DROP 3 PR# ; BASE ! ;S ( CLEAN, CLEAN.BLOCKS, CLEAR.BLOCKS ) ( 23 FEB 86 JBM ) BASE @ FORTH DEFINITIONS HEX : CLEAN ( screen# -- CHANGE COTROL CHRACTERS TO SPACES ) BLOCK DUP 400 + SWAP DO I C@ 20 < IF 20 I C! THEN LOOP UPDATE ; : CLEAN.BLOCKS ( first last -- CLEAN FIRST THRU LAST BLOCKS ) 1+ SWAP DO I CLEAN LOOP FLUSH ; : CLEAR.BLOCKS ( first last -- CLEAR FIRST THRU LAST BLOCKS ) 1+ SWAP DO I EDITOR CLEAR LOOP FLUSH ; BASE ! ;S ( FORTH 65C02 ASSEMBLER 1 ) ( 22 FEB 86 JBM )( BY WILLIAM F. RAGSDALE; DR. DOBB'S JOURNAL 9/81 ) ( ADAPTED FOR 65C02 OPCODES BY JOHN B. MATTHEWS ) BASE @ HEX VOCABULARY ASSEMBLER IMMEDIATE ASSEMBLER DEFINITIONS ( CONSTANT ASSIGNMENTS SPECIFIC TO IMPLEMENTATION ) F5 CONSTANT XSAVE F1 CONSTANT W F3 CONSTANT UP EE CONSTANT IP E6 CONSTANT N ' (DO) 0E + CONSTANT POP ' (DO) 0C + CONSTANT POPTWO ' LIT 13 + CONSTANT PUT ' LIT 11 + CONSTANT PUSH ' LIT 18 + CONSTANT NEXT ' EXECUTE NFA 11 - CONSTANT SETUP --> ( FORTH 65C02 ASSEMBLER 2 ) ( 22 FEB 86 JBM )0 VARIABLE TBL -2 ALLOT 0808 , 1404 , 0014 , 1110 , FFFF , 1C0C , 3C18 , 2CFF , 00FF , 1404 , FF14 , FFFF , FFFF , 1C0C , FF1C , FFFF , FFFF , 1404 , FFFF , FFFF , FFFF , 3E3C , FFFF , FFFF , 2 VARIABLE MODE : .A 0 MODE ! ; : # 1 MODE ! ; : MEM 2 MODE ! ; : ,X 3 MODE ! ; : ,Y 4 MODE ! ; : X) 5 MODE ! ; : )Y 6 MODE ! ; : ) 7 MODE ! ; : TOS ,X 0 ; ( ADDRESS THE TOP OF THE STACK ) : SEC ,X 2 ; ( ADDRESS SECOND ITEM ON STACK ) : RP) ,X 101 ; ( ADDRESS BOTTOM OF RETURN STACK ) : BOT TOS ; ( FOR COMPATIBILITY WITH OLD VERSION ) --> ( FORTH 65C02 ASSEMBLER 3 ) ( 22 FEB 86 JBM ) : CPU <BUILDS C, DOES> C@ C, MEM ; ( SINGLE-MODE OP-CODES ) 00 CPU BRK, 18 CPU CLC, D8 CPU CLD, 58 CPU CLI, B8 CPU CLV, 3A CPU DEA, CA CPU DEX, 88 CPU DEY, 1A CPU INA, E8 CPU INX, C8 CPU INY, EA CPU NOP, 48 CPU PHA, 08 CPU PHP, DA CPU PHX, 5A CPU PHY, 68 CPU PLA, 28 CPU PLP, FA CPU PLX, 7A CPU PLY, 40 CPU RTI, 60 CPU RTS, 38 CPU SEC, F8 CPU SED, 78 CPU SEI, AA CPU TAX, A8 CPU TAY, BA CPU TSX, 8A CPU TXA, 9A CPU TXS, 98 CPU TYA, : VAL 1 MODE @ 0F AND -DUP IF 0 DO DUP + LOOP THEN OVER 2+ @ AND ; ( TRUE IF THIS OP'S MODE BIT SET ) : !OP C@ MODE C@ TBL + C@ + C, ; : BAD MEM CR LATEST ID. 3 ERROR ; --> ( FORTH 65C02 ASSEMBLER 4 ) ( 22 FEB 86 JBM ): MPU <BUILDS , , DOES> ( MULTI-MODE OP-CODES ) DUP 1+ C@ 10 * MODE +! MODE @ 0F AND 0= IF VAL IF !OP ELSE BAD THEN ELSE OVER FF00 AND 0= IF VAL IF !OP C, THEN ELSE 8 MODE +! VAL IF !OP , ELSE BAD THEN THEN THEN MEM ; 1CEE 0061 MPU ADC, 1CEE 0021 MPU AND, 0C0D 0002 MPU ASL, 0C0C 0020 MPU BIT, 1CEE 00C1 MPU CMP, 0406 01E0 MPU CPX, 0406 01C0 MPU CPY, 0C0C 00C2 MPU DEC, 1CEE 0041 MPU EOR, 0C0C 00E2 MPU INC, A400 0040 MPU JMP, 0400 0014 MPU JSR, 1CEE 00A1 MPU LDA, 1416 01A2 MPU LDX, 0C0E 01A0 MPU LDY, 0C0D 0042 MPU LSR, 1CEE 0001 MPU ORA, 0C0D 0022 MPU ROL, 0C0D 0062 MPU ROR, 1CEE 00E1 MPU SBC, 1CEE 0081 MPU STA, 0414 0082 MPU STX, 040C 0080 MPU STY, 0C0C 0260 MPU STZ, 0202 0010 MPU TRB, 0202 0000 MPU TSB, --> ( FORTH 65C02 ASSEMBLER 5 ) ( 22 FEB 86 JBM ): BEGIN, HERE 1 ; IMMEDIATE : UNTIL, ?EXEC >R 1 ?PAIRS R> C, HERE 1+ - C, ; IMMEDIATE : IF, C, HERE 0 C, 2 ; IMMEDIATE : THEN, ?EXEC 2 ?PAIRS HERE OVER C@ IF SWAP ! ELSE OVER 1+ - SWAP C! THEN ; IMMEDIATE : ELSE, 2 ?PAIRS HERE 1+ 1 JMP, SWAP HERE OVER 1+ - SWAP C! 2 ; IMMEDIATE : NOT 20 + ; ( REVERSE ASSEMBLY TEST ) 90 CONSTANT CS ( ASSEMBLER TEST FOR CARRY SET ) 50 CONSTANT VS ( ASSEMBLER TEST FOR OVERFLOW SET ) D0 CONSTANT 0= ( ASSEMBLER TEST FOR EQUAL ZERO ) 10 CONSTANT 0< ( ASSEMBLER TEST FOR LESS THAN ZERO ) 90 CONSTANT >= ( ASSEMBLER TEST FOR GREATER THAN OR EQUAL ) ( >= ONLY CORRECT AFTER SUB, OR CMP, ) --> ( FORTH 65C02 ASSEMBLER 6 ) ( 22 FEB 86 JBM ): END-CODE ( END OF CODE DEFINITION ) CURRENT @ CONTEXT ! ?EXEC ?CSP SMUDGE ; IMMEDIATE FORTH DEFINITIONS : CODE ( CREATE WORD AT ASSEMBLY CODE LEVEL ) ?EXEC CREATE [COMPILE] ASSEMBLER ASSEMBLER MEM !CSP ; IMMEDIATE ( CAUSE ;CODE TO INVOKE ASSEMBLER ) ' ASSEMBLER CFA ' ;CODE 8 + ! ( OVERWRITE SMUDGE IN ;CODE ) FORTH DEFINITIONS BASE ! ;S ( TO LOCK ASSEMBLER, LOAD SYSTEM INSTALLATION SCREEN ) ( ASSEMBLER EXAMPLES: 2* 2/ ) ( 16 FEB 86 JBM ) CODE 2* ( n -- n double the number on TOS using shift left ) TOS ASL, ( asl 0,x shift low order byte of TOS ) TOS 1+ ROL, ( rol 1,x rotate hi order byte of TOS ) NEXT JMP, ( jmp next return to the interpreter ) END-CODE ( ends CODE definition as ; does for : ) CODE 2/ ( n -- n halve the number on TOS using shift right ) TOS 1+ LSR, TOS ROR, NEXT JMP, END-CODE ;S ( ASSEMBLER EXAMPLES: CON VAR ) ( 16 FEB 86 JBM ) ( THE FOLLOWING IS IDENTICAL TO THE DEFINING WORD 'CONSTANT' ) : CON CREATE SMUDGE , ;CODE 2 # LDY, W )Y LDA, PHA, INY, W )Y LDA, PUSH JMP, END-CODE ( THE FOLLOWING IS IDENTICAL TO THE DEFINING WORD 'VARIABLE' ) : VAR CON ;CODE CLC, W LDA, 2 # ADC, PHA, TYA, W 1+ ADC, PUSH JMP, END-CODE ( FIG-FORTH DECOMPILER - BY RAY DUNCAN ) ( 15 FEB 86 JBM )( FROM DR. DOBB'S JOURNAL SEPT. 1981 - CASE STATEMENT BY) ( CHARLES EAKER, FORTH DIMENSIONS II/3 PAGE 37) BASE @ FORTH DEFINITIONS DECIMAL : CASE ?COMP CSP @ !CSP 4 ; IMMEDIATE : OF 4 ?PAIRS COMPILE OVER COMPILE = COMPILE 0BRANCH HERE 0 , COMPILE DROP 5 ; IMMEDIATE : ENDOF 5 ?PAIRS COMPILE BRANCH HERE 0 , SWAP 2 [COMPILE] ENDIF 4 ; IMMEDIATE : ENDCASE 4 ?PAIRS COMPILE DROP BEGIN SP@ CSP @ = 0= WHILE 2 [COMPILE] ENDIF REPEAT CSP ! ; IMMEDIATE --> ( FIG-FORTH DECOMPILER - CONT'D ) ( 15 FEB 86 JBM )0 VARIABLE QUIT.FLAG 0 VARIABLE WORD.PTR ( FIND RUNTIME ADDRESSES OF EACH VOCABULARY WORD TYPE ) ' (LOOP) 2 - CONSTANT LOOP.ADR ' LIT 2 - CONSTANT LIT.ADR ' CLIT 2 - CONSTANT CLIT.ADR ' : 2 - @ CONSTANT DOCOL.ADR ' 0BRANCH 2 - CONSTANT 0BRANCH.ADR ' BRANCH 2 - CONSTANT BRANCH.ADR ' (+LOOP) 2 - CONSTANT PLOOP.ADR ' (.") 2 - CONSTANT PDOTQ.ADR ' C/L 2 - @ CONSTANT CONST.ADR ' BASE 2 - @ CONSTANT USERV.ADR ' USE 2 - @ CONSTANT VAR.ADR ' (;CODE) 2 - CONSTANT PSCODE.ADR --> ( FIG-FORTH DECOMPILER - CONT'D ) ( 15 FEB 86 JBM ) : N. ( PRINT A NUMBER IN DECIMAL AND HEX ) DUP DECIMAL . SPACE HEX 0 ." ( $" D. ." )" DECIMAL ; : PDOTQ.DSP ( DISPLAY A COMPILED TEXT STRING ) WORD.PTR @ 2 + DUP >R DUP C@ + 1 - WORD.PTR ! ( UPDATE PFA PTR ) R> COUNT TYPE ; : WORD.DSP ( GIVEN CFA, DISPLAY THE GLOSSARY NAME ) 3 - -1 TRAVERSE DUP 1+ C@ 59 = IF 1 QUIT.FLAG ! ENDIF ( IF ";" DONE) DUP C@ 160 AND 128 = ( MAKE SURE LEGAL NFA ) IF ID. ELSE 1 QUIT.FLAG ! ENDIF ; --> ( FIG-FORTH DECOMPILER - CONT'D ) ( 15 FEB 86 JBM ) : BRANCH.DSP ( GET BRANCH OFFSET, CLACULATE THE ) ( ACTUAL BRANCH ADDRESS AND DISPLAY IT ) ." TO " WORD.PTR @ 2+ DUP WORD.PTR ! ( UPDATE PFA PTR ) DUP @ + ( OFFSET + PFA = ACTUAL TARGET ADDR ) 0 HEX D. DECIMAL ( PRINT IT ) ; : USERV.DSP ( DISPLAY A USER VARIABLE ) ." USER VARIABLE, CURRENT VALUE = " WORD.PTR @ 2+ ( CALCULATE PFA ) C@ 16 +ORIGIN @ + ( THEN USER AREA ADDRESS ) @ N. ( FETCH AND PRINT CONTENTS ) 1 QUIT.FLAG ! ; --> ( FIG-FORTH DECOMPILER - CONT'D ) ( 15 FEB 86 JBM ) : VAR.DSP ( DISPLAY A VARIABLE ) ." VARIABLE, CURRENT VALUE = " WORD.PTR @ 2+ ( CALCULATE PFA ) @ N. 1 QUIT.FLAG ! ; : CONST.DSP ( DISPLAY A COMPILED CONSTANT ) ." CONSTANT, VALUE = " WORD.PTR @ 2+ @ N. 1 QUIT.FLAG ! ; --> ( FIG-FORTH DECOMPILER - CONT'D ) ( 15 FEB 86 JBM ): DIS BASE @ ( PRESERVE USER'S BASE ) -FIND 0= ( IS INPUT WORD IN DICTIONARY? ) IF ." ? NOT IN GLOSSARY" CR ( NO, QUIT ) ELSE 64 AND IF CR ." ** IMMEDIATE **" CR ENDIF DUP DUP 2 - ( YES - CALC CFA ) @ = ( IF CFA=PFA THEN IT'S A PRIMITIVE ) IF ." <PRIMITIVE>" CR ELSE ( HIGH LEVEL FORTH - DECODE IT ) 0 QUIT.FLAG ! ( INITIALIZE ) 2 - WORD.PTR ! CR BEGIN WORD.PTR @ DUP ( FETCH CURRENT PSEUDOCODE PTR ) 0 HEX D. SPACE DECIMAL ( PRINT PTR ) @ --> ( FIG-FORTH DECOMPILER - CONT'D ) ( 15 FEB 86 JBM )CASE ( DECODE SPECIAL WORD TYPES ) LIT.ADR OF WORD.PTR @ 2+ DUP WORD.PTR ! @ N. ENDOF CLIT.ADR OF WORD.PTR @ 1+ DUP WORD.PTR ! 1+ C@ N. ENDOF DOCOL.ADR OF ." :" ENDOF 0BRANCH.ADR OF ." BRANCH IF ZERO " BRANCH.DSP ENDOF BRANCH.ADR OF ." BRANCH " BRANCH.DSP ENDOF LOOP.ADR OF ." LOOP " BRANCH.DSP ENDOF PLOOP.ADR OF ." +LOOP " BRANCH.DSP ENDOF --> ( FIG-FORTH DECOMPILER - CONT'D ) ( 15 FEB 86 JBM ) PDOTQ.ADR OF ." '" PDOTQ.DSP ." '" ENDOF USERV.ADR OF USERV.DSP ENDOF VAR.ADR OF VAR.DSP ENDOF CONST.ADR OF CONST.DSP ENDOF PSCODE.ADR OF WORD.PTR @ @ WORD.DSP 1 QUIT.FLAG ! ENDOF --> ( FIG-FORTH DECOMPILER - END ) ( 15 FEB 86 JBM ) DUP WORD.DSP ( ALL SPECIAL WORDTYPES CHECKED ) ( IF WORD DID NOT MATCH ANY CASE ) ( JUST PRINT IT'S NAME ) ENDCASE CR 2 WORD.PTR +! ( UPDATE PSEUDOCODE PTR ) QUIT.FLAG @ ( CHECK IF FINISHED OR ) UNTIL ( GET ANOTHER WORD ) THEN THEN CR BASE ! ; BASE ! ;S ( S., PR#, TEXT, LINE ) ( 23 JAN 86 JBM )BASE @ HEX FORTH DEFINITIONS 6 USER S0 ( S0 HOLDS THE ORIGNAL STACK VALUE FROM BOOT ) : S. SP@ S0 @ SWAP OVER OVER = IF ." Stack empty" DROP DROP CR ELSE DO I @ 6 .R CR 2 +LOOP THEN ; ( PRINT A STACK IMAGE ) : PR# DUP 0= IF FE93 CALL DROP ELSE 0 36 C! C0 OR 37 C! THEN CR 3EA CALL ; ( slot# -- DO I/O USING SLOT# ) ( USED BY EDITOR ) : TEXT HERE C/L 1+ BLANKS WORD HERE PAD C/L 1+ CMOVE ; : LINE DUP FFF0 AND 17 ?ERROR SCR @ (LINE) DROP ; --> ( EDITOR 1 ) ( 23 JAN 86 JBM )VOCABULARY EDITOR IMMEDIATE EDITOR DEFINITIONS : #LOC R# @ C/L /MOD ; : #LEAD #LOC LINE SWAP ; : #LAG #LEAD DUP >R + C/L R> - ; : -MOVE LINE C/L CMOVE UPDATE ; : H LINE PAD 1+ C/L DUP PAD C! CMOVE ; : E LINE C/L BLANKS UPDATE ; : R PAD 1+ SWAP -MOVE ; : P 1 TEXT R ; : S DUP 1 - 0E DO I LINE I 1+ -MOVE -1 +LOOP E ; : D DUP H 0F DUP ROT DO I 1+ LINE I -MOVE LOOP E ; : I DUP S R ; --> ( EDITOR 2 ) ( 23 JAN 86 JBM ): M R# +! #LOC 3 .R DROP SPACE #LEAD TYPE 5F EMIT #LAG TYPE ; : T DUP C/L * R# ! DUP H 0 M ; : L 0C EMIT SCR @ LIST 0 M ; : C 1 TEXT PAD COUNT #LAG ROT OVER MIN >R FORTH R R# +! R - >R DUP HERE R CMOVE HERE #LEAD + R> CMOVE R> CMOVE UPDATE 0 M ; : TOP 0 R# ! ; : CLEAR DUP SCR ! BLOCK 400 BLANKS UPDATE ; : COPY SWAP BLOCK 2 - ! UPDATE ; : BLOCKS 0 DO OVER FORTH I + OVER FORTH I + EDITOR COPY LOOP DROP DROP FLUSH ; --> ( EDITOR 3 ) ( 27 MAR 86 JBM )HEX CREATE MATCH 04A9 , 6C20 , CA08 , CACA , 94CA , 9400 , A001 , C8FF , E6C4 , 2CB0 , E8B1 , ECD1 , F5F0 , ECE6 , 02D0 , EDE6 , 00F6 , 02D0 , 01F6 , EAA5 , 02D0 , EBC6 , EAC6 , EAA5 , E6C5 , EBA5 , E7E5 , D5B0 , 00A9 , 0295 , 0395 , EAA4 , 9818 , 0075 , A948 , 7500 , 4C01 , 083F , SMUDGE --> ( EDITOR 4 ) ( 27 MAR 86 JBM ) : 1LINE #LAG PAD COUNT MATCH R# +! ; : FIND BEGIN 3FF R# @ < IF TOP PAD HERE C/L 1+ CMOVE 10 ERROR THEN 1LINE UNTIL ; : DELETE ( DELETE TOS# OF CHARACTERS TO THE LEFT ) >R #LAG + FORTH R - #LAG R MINUS R# +! #LEAD + SWAP CMOVE R> BLANKS UPDATE ; --> ( EDITOR 5 ) ( 27 MAR 86 JBM ) : N ( FIND NEXT OCCURANCE OF SAME STRING ) FIND 0 M ; : F ( FIND FOLLOWING TEXT ) 1 TEXT N ; : B ( BACKUP CURSOR BY PAD ) PAD C@ MINUS M ; : X ( DELETE FOLLOWING TEXT ) 1 TEXT FIND PAD C@ DELETE 0 M ; : TILL ( DELETE FROM CURSOR TO END OF LINE ) #LEAD + 1 TEXT 1LINE 0= 10 ?ERROR #LEAD + SWAP - DELETE 0 M ; --> ( WHERE, >>, <<, L ) ( 14 FEB 86 JBM )FORTH DEFINITIONS : WHERE ( Screen # and image of error ) OVER OVER DUP 0= IF ." Last error from terminal" ELSE ." Error in Scr # " DUP SCR ! DUP DECIMAL . SWAP C/L /MOD C/L * ROT BLOCK + CR C/L TYPE CR 1 - SPACES 5E EMIT [COMPILE] EDITOR THEN SP! QUIT ; : >> SCR @ 1+ LIST ; : << SCR @ 1 - LIST ; : L [COMPILE] EDITOR EDITOR L ; FORTH BASE ! ;S ( EDITOR SUMMARY 1 ) ( 24 JAN 86 JBM )H Hold line# tos in PAD (line# -- ) E Erase line# tos (line# -- ) R Replace line# tos with contents of PAD (line# -- ) P Put following text in line# tos (line# --) S Spread lines at line# tos (line# -- ) D Delete line# tos to PAD and move lines up (line# --) I Insert PAD at line# tos and move lines down (line# --) M Move cursor forward or backward by tos characters (n --) T Type line# tos and save in PAD (line# -- line#) L List current screen (--) CLEAR Clear screen# tos (screen# --) COPY Copy screen# nos to screen# tos (source dest --) BLOCKS Copy a range of screens (source dest count --) ( EDITOR SUMMARY 2 ) ( 24 JAN 86 JBM )C Copy following text at the cursor spreading characters (--) F Find the next occurrence of the text following F (--) N Find the next occurrence of the same text (--) B Backup the number of characters in the PAD (--) X Find the next occurrence of the text following X and delete itTOP Moves the cursor to the beginning of the first line (--) TILL find the next occurrence of the text following TILL and delete from the cursor position up to and including the text L Typed when FORTH is the CURRENT vocabulary will list the current screen and invoke the EDITOR You can use the "escape" editing commands in conjunction with the P command to edit lines on the screen. Control-X will cancelwhatever you've typed since the last RETURN. If a screen gets mangled, EMPTY-BUFFERS will prevent it from getting to disk.
